Numere puternic compuse (Pregatire lot, Cluj, aprilie 1996)

        Sa se scrie un program care genereaza numerele "puternic compuse"
N<10.000.000.
        Numerele "puternic compuse" sunt acele numere naturale care au numarul
divizorilor mai mare decat numarul divizorilor oricarui numar natural mai mic
decat numarul respectiv.
=========================================

Solutia 1 (Angel Proorocu - Ploiesti):
program GenarareaNumerelorCompuse;

   uses Crt;

   const np:array[1..13]of byte=(2,3,5,7,11,13,17,19,23,29,31,37,41);

   var a:array[1..1000]of extended;
       diviz:array[1..1000]of longint;
       min,lim:extended;
       n,nrdiv:longint;

procedure ReadData;
   begin
     clrscr;
     writeln('Care este numarul N ?');
     readln(lim);
     writeln;
   end;

function nrd(a:extended):longint;
  var i,j:longint;
      b:extended;
      aa:array[1..13]of longint;
  begin
    for i:=1 to 13 do aa[i]:=0;
    j:=0;
    for i:=1 to 13 do
     begin
      b:=a/np[i];
      while a/np[i]=int(b) do
       begin
        inc(aa[i]);
        a:=a/np[i];
        b:=a/np[i];
       end;
     end;
    for i:=12 downto 1 do
     if aa[i]<>0 then
     aa[i]:=aa[i]+aa[i]*aa[i+1]+aa[i+1] else aa[i]:=aa[i+1];
    nrd:=aa[1];
  end;

procedure Rezolva;
   var i,j,nn,nnr:longint;
       urm:extended;
       sw:boolean;
   begin
     a[1]:=1;
     if lim=1 then
       begin
        writeln('1');
        readkey;
        halt;
       end;
     n:=1;
     nrdiv:=0;
     while a[n]<=lim do
      begin
       writeln(a[n]:0:0);
       readkey;
       if a[n]=lim then halt;
       min:=lim;
       sw:=true;
       for j:=1 to n do
        for i:=1 to 13 do
         begin
           urm:=np[i]*a[j];
           if (urm>a[n])and(urm<=min) then
	    begin
             nn:=nrd(urm);
             if nn>nrdiv then
              begin
                sw:=false;
                min:=urm;
                nnr:=nn;
              end;
            end;
         end;
       if sw then halt;
       inc(n);
       a[n]:=min;
       diviz[n]:=nnr;
       nrdiv:=nnr;
      end;
     writeln('Apasa o tasta...');
   end;

begin
  ReadData;
  Rezolva;
end.
-------------------------
Solutia 2 (Virgil Serbanuta)
{$A+,B-,D+,E+,F-,G-,I+,L+,N+,O-,P-,Q+,R+,S+,T-,V+,X+,Y+}
{$M 16384,0,655360}
const gen:array[1..14] of byte=(2,3,5,7,11,13,17,19,23,29,31,33,37,41);
      maximu=1000000001;
      maxfor=1700;
var max:array[1..2000] of comp;
    smax,ma,mi:comp;
    n,nmax,i,j:word;
label l;

function pow(i,j:word):comp;
var a:comp;
begin
a:=1;
for j:=1 to j do
    begin
    a:=a*i;
    if a>maximu then
       begin
       pow:=a;
       exit;
       end;
    end;
pow:=a;
end;

procedure back(k,n,prec:word;s:comp);
var i:word;
begin
if n=1 then
   if s<smax then
      smax:=s
   else else
for i:=1 to n shr 1 do
    if (n mod i=0) and (n div i<=prec) then
       begin
       back(k+1,i,n div i,s*pow(gen[k],n div i-1));
       end;
end;

begin
writeln('Dati capetele intervalului (pana in 100.000.000)');
readln(mi,ma);
for n:=1 to maxfor do
    begin
    smax:=maximu;
    back(1,n,n,1);
    if smax<maximu then
       begin
       inc(nmax);
       max[nmax]:=smax;
       end;
    end;
for i:=1 to nmax do
    if (max[i]>=mi) and (max[i]<=ma) then
    begin
    for j:=i+1 to nmax do
        if max[j]<=max[i] then
           goto l;
    writeln(max[i]:10:0);
    l:
    end;
end.
-------------------------
Solutia 3 (Adrian Carcu)
var i,j,n,np,min:longint;
    p,x:array[0..1000] of integer;
    ind:boolean;
    fis:text;

procedure test(k:integer);
var prod:longint;
    i,j:integer;
begin
   prod:=1;
   for i:=1 to k do
      for j:=1 to x[k-i+1]-1 do if prod<maxlongint/p[i] then prod:=prod*p[i];
   if prod<min then min:=prod;
end;

procedure rec(k,n:integer);
var i:integer;
begin
   if n=1 then test(k)
   else for i:=x[k] to n do if n mod i=0 then begin
                         x[k+1]:=i;
                         rec(k+1,n div i);
                         end;
end;

function numar(n:integer):longint;
begin
   min:=maxlongint; x[0]:=2;
   rec(0,n);
   numar:=min;
end;

begin
   np:=0;
   for i:=2 to 1000 do begin
      ind:=true;
      for j:=2 to trunc(sqrt(i)) do if i mod j=0 then ind:=false;
      if ind then begin inc(np); p[np]:=i; end;
      end;

   n:=10000000;
   {assign(fis,'nr_compu.dat'); rewrite(fis);}
   i:=1;
   for i:=1 to 448 do begin
      j:=numar(i);
      if j<n then writeln({fis,}j,' are ',i,' divizori')
             {else writeln(fis,'nu exista ',i,' divizori')};
      end;
   {close(fis);}
end.
-----------------------
Solutia 4 (Ovidiu Ghiorghioiu)
{ Problema cu numerele compuse pana la un numar dat (sau -1 pt. maxim posibil)} 
uses crt;

const nrp=12;

const np:array[1..nrp] of integer=(2,3,5,7,11,13,17,19,23,29,31,37);

var a:array[1..nrp] of integer;
    s:array[1..1000] of longint;
    q:array[1..nrp] of boolean;
    i,j,k,ns:integer;
    ls,min:longint;
    f:text;

function nd(what:longint):integer;
var a,b:integer;
begin
     if what<0 then begin
        writeln('Depasire!');
        close(f);
        halt;
     end;
     a:=1;
     for i:=1 to nrp do begin
         b:=a;
         while what mod np[i]=0 do begin
               what:=what div np[i];
               inc(a,b);
         end;
     end;
     nd:=a;
end;

begin
     write('Limita superioara: ');readln(ls);
     for i:=1 to nrp do a[i]:=1;
     s[1]:=1;ns:=1;
     assign(f,'compuse.out');rewrite(f);
     writeln(f,1);
     repeat
           min:=maxlongint;
           for i:=1 to nrp do
               if s[a[i]]*np[i]<min then min:=s[a[i]]*np[i];
           if (min>ls) and (ls>=0) then break;
           k:=nd(min);
           inc(ns);
           s[ns]:=min;
           writeln(f,min);
           for j:=1 to nrp do
               while nd(s[a[j]]*np[j])<=k do inc(a[j]);
     until false;
     close(f);
end.
--------------------------
